home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / print-u.lisp < prev    next >
Encoding:
Text File  |  1992-10-27  |  64.7 KB  |  1,624 lines  |  [TEXT/CCL2]
  1. (in-package :ccl)
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;; print-u.lisp
  4. ;;
  5. ;; Copyright  1992 University of Toronto, Department of Computer Science
  6. ;; All Rights Reserved
  7. ;;
  8. ;; author: Mark A. Tapia markt@dgp.toronto.edu or markt@dgp.utoronto.ca
  9. ;;
  10. ;; print-u is a package for printing windows and documents. 
  11. ;; The following methods and functions are exported:
  12. ;;        get-printer-error    for returning the error condition or nil (no error)
  13. ;;        page-size            point indicating the page size used for printing
  14. ;;        picture-hardcopy     for quickdraw pictures
  15. ;;        print-contents       for drawing the nested views of a window
  16. ;;        view-print-contents  for printing a series of views
  17. ;;
  18. ;; Internal (unexported) routines of interest
  19. ;;        document-hardcopy    for printing a general document
  20. ;;        window-hardcopy      for printing the contents of a window using
  21. ;;                             print-contents
  22. ;;        default-prec         creates a default private print record
  23. ;;        update-file-prec     saves a copy of a private print record in a resource 
  24. ;;        view-file-name       the pathname of the file associated with a view      
  25.  
  26. ;;
  27. ;; Acknowledgements:
  28. ;;     This code is based on print-utils.lisp written by DEH 6/20/91 and
  29. ;;     based on hardcopy.lisp with copyright 1988-89 Apple Computer, Inc. 
  30. ;;     The print-utils code has been modified to work in MCL2.0 and
  31. ;;     to print the contents of other views and to support generalized printing.
  32. ;;
  33. ;;     This code also uses the with-view-font and with-pen-state macros
  34. ;;     from oodles-of-utils:quickdraw-u.lisp by Michael S. Engber.
  35. ;;     Copyright  1991 Northwestern University Institute for the Learning Sciences
  36. ;;     All Rights Reserved.
  37. ;;
  38. ;;     Support for private print records was based on suggestions by Gregory
  39. ;;     Wilcox. The ideas were refined by Bill St. Clair.
  40. ;;
  41. ;; Update history:
  42. ;;  1992-06-07  Added page-size method for retrieving the page size
  43. ;;  1992-10-26  Support added for private print records stored with the
  44. ;;              file in the resource fork (:type :prec :resource-id 128).
  45. ;;
  46. ;; NOTE: Every window has a private print record which controls the
  47. ;;       way the window will be printed and the attributes in the
  48. ;;       print-style-dialog box. The private print record is stored in the
  49. ;;       resource fork of the file when it is saved (:type :prec :resource-d 128)
  50. ;;       and when the Page Setup method is selected.
  51. ;;       The private print record is restored when the file is edited again.
  52. ;;       
  53. ;;       Every specific view uses the private print record of the outermost
  54. ;;       view containing the specific view.
  55. ;;
  56. ;;       A private print record of a window is saved when the window
  57. ;;       is saved (using Save, Save As, or Save Copy As and when the
  58. ;;       window is closed and needs to be saved. Methods are defined
  59. ;;       for fred windows.
  60. ;;
  61. ;;       For all other windows, you must provide a method for saving
  62. ;;       the file (ccl::window-save using ccl::window-file-save which
  63. ;;       must return the pathname) and a method for (view-file-name window)
  64. ;;        
  65. ;;       When a titled fred-window is saved (using the file menu
  66. ;;       items "save", "Save As ..." "Save Copy As..."), the page 
  67. ;;       setup attributes are saved in a print record in the file. 
  68. ;;       The record is placed in the :prec resource with id 128.  
  69. ;;       When the file is reopened in a fred-window, the page setup 
  70. ;;       attributes are restored.
  71. ;;    
  72. ;;
  73. ;;       Every other object uses a shared, public print record *print-hc-prec*.
  74. ;;       This print record is initialized at the beginning of a session.
  75. ;;
  76. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  77. ;;
  78. ;; Warnings:
  79. ;;     1. If you are running MCL2.0b1p3 or earlier, you must change
  80. ;;        the defparameter statement for mcl-final to the following:
  81. ;;          (defparameter mcl-final nil)
  82.  
  83. (defparameter mcl-final t)
  84.  
  85. ;;
  86. ;;     2. This code will only work if the records definitions in the
  87. ;;        library;interfaces:printTraps.lisp are correct. 
  88. ;;        See the note below.
  89. ;;
  90. ;;     3. The code has been tested with LaserWriters but has not
  91. ;;        been tested with ImageWriters, StyleWriters etc. The routines
  92. ;;        use standard quickdraw calls.
  93. ;;
  94. ;;     4. This code changes the File menu-items for Page Setup and Print.
  95. ;;        The Page Setup menu item is changed to a window-menu-item and
  96. ;;        the associated menu-item action is #'ccl::page-setup. 
  97. ;;        Changing the page setup for a window does not affect
  98. ;;        other windows.
  99. ;;        
  100. ;;     5. Printing can only be cancelled by pressing Command-period.
  101. ;;        Printing cannot be stopped while the current page is being
  102. ;;        printed. but will be stopped before printing the next page.
  103. ;;  
  104. ;;     6. Due to a bug in background printing, we cannot display the
  105. ;;        current page being printed under certain conditions.
  106. ;;        When the print monitor is displaying the status of printing
  107. ;;        (with background printing off), (event-dispatch) does not return.
  108. ;;        As a result, the print progress dialog box does not indicate the
  109. ;;        page number of the page being printed.
  110. ;;
  111. ;;     7. The internal code for printing a document runs without interrupts
  112. ;;        with the result that no other work can proceed until either
  113. ;;        the hardcopy routine returns (or aborts) or is cancelled by
  114. ;;        pressing command-period.
  115. ;;         
  116. ;;
  117. ;;  Six examples of using the package are included at the end of this file:
  118. ;;    four printing examples, for printing various objects:
  119. ;;    - a small window
  120. ;;    - a picture
  121. ;;    - a large window
  122. ;;    - a general document
  123. ;;    and two examples of using private print records
  124. ;;    - creating a file, changing its print record, saving it and restoring it.
  125. ;;    - developing a class of views that store a print record in a slot
  126. ;;
  127. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  128.  
  129. #|
  130. ;;---------------------------Note-------------------------------------
  131.  
  132. ****Warning****
  133. Before loading this file, evaluate
  134.     (record-length :TPrint)
  135. This should return 120.
  136.  
  137. If the record-length is not 120, the tprstl and tprxinfo records 
  138. in the file printTraps.lisp in interfaces folder in the library
  139. folder must be replaced by the following: 
  140.  
  141. (defrecord tprstl
  142.   (wdev :signed-integer)
  143.   (ipagev :signed-integer)
  144.   (ipageh :signed-integer)
  145.   (bport :signed-byte)
  146.   (feed :unsigned-byte))
  147.  
  148. (defrecord tprxinfo
  149.   (irowbytes :signed-integer)
  150.   (ibandv :signed-integer)
  151.   (ibandh :signed-integer)
  152.   (idevbytes :signed-integer)
  153.   (ibands :signed-integer)
  154.   (bpatscale :signed-byte)
  155.   (bulthick :signed-byte)
  156.   (buloffset :signed-byte)
  157.   (bulshadow :signed-byte)
  158.   (scan :unsigned-byte)
  159.   (bxinfox :signed-byte))
  160.  
  161. Perform the following steps to update the record definitions:
  162. 1. Replace the record definitions in the source file
  163.    library;interfaces:printTraps.lisp with the definitions above. 
  164. 2. Evaluate the following expression to rebuild the index files
  165.    (ccl::reindex-interfaces)
  166.    You will now be able to access the new record definitions.
  167. 3. Quit from MCL. To free up the cons space.
  168. 4. Startup MCL again.
  169.  
  170. ----------------------Exported routines------------------------
  171.  
  172. The following exported routines allow the user to change the 
  173. print style for windows. Changing a print style only affects the
  174. current session. The print styles are reset upon re-entering MCL
  175. and are not stored with the document. Changing the style for 
  176. a fred window only changes the style of all fred windows during
  177. the session. Similarly changing the style of a non-fred window 
  178. only changes the styles for all fred windows.
  179.  
  180. page-setup                              ; method
  181. Changes the print style for a window.
  182.  
  183. (page-setup fred-window)
  184. Same as selecting the file Page Setup menu item from the
  185. standard *file-menu*.
  186. Displays the page setup dialog box and allows the user to
  187. change the style attributes for printing the window
  188. but does not affect the style for printing other windows
  189. or documents.
  190.  
  191. (page-setup t)
  192. Displays the page setup dialog box and allows the user to
  193. change the style attributes for all items that do not have
  194. private print records.
  195.  
  196. page-size                              ; method
  197. Returns a point indicating the page size used for printing
  198. fred or non-fred windows. The page-size for a fred window 
  199. may be different from that of a non-fred window.
  200.  
  201. (page-setup fred-window)
  202. (page-setup t)
  203.  
  204. The following exported routines direct output to a printer or
  205. to a PostScript file.
  206.  
  207. picture-hardcopy                        ; function
  208. picture-hardcopy picture &optional show-dialog?
  209.   Directs the quickdraw picture to the printer
  210.     picture       a picture
  211.     show-dialog?  ignored
  212.  
  213.    If no printer errors occurred and the user did not cancel
  214.       returns nil
  215.    otherwise 
  216.       returns the non-zero print error code which caused the termination
  217.  
  218. print-contents                          ; method
  219. print-contents view &optional (offset #@(0 0))
  220. Executes the quickdraw commands for drawing the contents of a view.
  221.  
  222. When offset is #@(0 0), uses local coordinates for drawing,
  223. otherwise adjusts coordinates by subtracting offset from coordinates.
  224.  
  225. Print-contents supports the following types of views:
  226.     window                    - draws a box around the content area
  227.                                 of the window and prints the contents
  228.                                 of the subviews.
  229.  
  230.     static-text-dialog-item   - draws a box around the item
  231.                                 and prints the text with the view font
  232.  
  233.     editable-text-dialog-item - draws a box around the item
  234.                                 and prints the text with the view font
  235.  
  236.     button-dialog-item        - draws the button and the text within
  237.  
  238.     view                      - prints the contents of the subviews
  239.  
  240.     sv                        - does nothing
  241.  
  242. get-printer-error                       ; function
  243. (get-printer-error)
  244. either returns nil or a printer-condition
  245. If nil, indicates no errors occurred during the last print request.
  246. Otherwise, returns the printer-condition with slots:
  247. phase - either $err-printer??? or nil
  248. code  - either the code returned from the printer operation or nil
  249. cond  - either nil or an error condition when not a printer error
  250.  
  251. ----------------------Unexported routines------------------------
  252.  
  253. Window-hardcopy prints the contents of a window.
  254. Specialize if you want to acheive different effects for
  255. other kinds of windows.
  256.  
  257. Use view-print-contents to initiate the printing of a view
  258. and all of its subviews.
  259.  
  260. Use the print-contents methods as the basis for developing
  261. methods for other types of views.
  262.  
  263. Document-hardcopy is a general routine that forms the basis
  264. for other print routines. Call this routine if you want
  265. to develop your own custom printing functions fo documents
  266. and windows.
  267.  
  268. window-hardcopy                         ; method
  269. window-hardcopy (window window) &optional (show-dialog? t)
  270.    Prints the window, The show-dialog? parameter is present
  271.    for compatibility with the standard method for fred-windows
  272.    and is used to display the print job dialog.
  273.    
  274.    The basic routine calls print-contents on the window, which
  275.    repeatedly calls print-contents on the views and subviews.
  276.  
  277.    If no printer errors occurred and the user did not cancel
  278.       returns t
  279.    otherwise 
  280.       returns nil indicating an error occurred in printing
  281.  
  282.     Parameters
  283.       window           the window to be printed
  284.        show-dialog?    display the print job dialog (default t)
  285.  
  286.  
  287. document-hardcopy                       ; not exported
  288. document-hardcopy  print-fn compute-doc-size &key view (show-dialog? t)
  289.    Prints a document. The show-dialog? parameter is present
  290.    for compatibility with the standard method for printing 
  291.    fred-windows and is used to display the print job dialog.
  292.  
  293.    This routine is the basis for picture-hardcopy and window-hardcopy.
  294.    Use document-hardcopy to build other specialized hardcopy routines.
  295.  
  296.    If no printer errors occurred and the user did not cancel
  297.       returns t
  298.    otherwise 
  299.       returns nil indicating an error occurred in printing
  300.  
  301.    The routine performs the following sequence of operations
  302.    1. Opens the printer
  303.    2. Displays the print job dialog box which indicates the method for cancelling.
  304.    3. Retrieves the print record
  305.    4. Determines the page layout using the rectangle corners
  306.       returned by the document-corners function
  307.    5. Opens the printer document
  308.    6. While there are pages to print and the user has not pressed cancel
  309.          For each page in the document that is to be printed, repeats the 
  310.          following steps
  311.             a. opens the page
  312.             b. draws the page using the print-fn
  313.             c. closes the page
  314.    7. Closes the printer document
  315.    8. Closes the printer
  316.    9  If no printer errors occurred and the user did not cancel
  317.          returns t
  318.       otherwise 
  319.          returns nil indicating an error occurred in printing
  320.       Use (get-printer-error) to retrive the printer error condition.
  321.  
  322.     Parameters
  323.     document-corners 
  324.                   Function that computes the corners of the document
  325.                   Parameters:
  326.                        view         the view associated with the document
  327.                        page-size    a point representing the size of the
  328.                                     page-rectangle in pixels
  329.                   Returns the corners of the document rectangle
  330.                   Where the default points are #@(0 0) page-size
  331.                        topleft      the top left corner
  332.                        bottomRight  the bottom right corner
  333.                   If document-corners is not a function, uses the routine
  334.                   default-document-corners which returns the points defining
  335.                   the page rectangle.
  336.  
  337.    print-fn       Function that draws a picture of the document.
  338.                   Parameters:
  339.                        view        suppled by the view keyword. This should be a view
  340.                                    or nil.
  341.                        page-size   the page rectangle size as a point (top left = #@(0 0))
  342.                        page-no     the current page being printed
  343.                        offset      the top left corner of the portion of the document
  344.                   If local, prints the rectangular portion of the document defined 
  345.                      by the points offset (add-points offset page-size). The
  346.                      coordinates are unchanged.
  347.                   Otherwise, adjusts the coordinates by subtracting offset
  348.                      from all points to print within the page rectangle #@(0 0)
  349.                      page-size.
  350.  
  351.                   If print-fn is not a function, uses default-document-hardcopy
  352.                   which does nothing.
  353.  
  354.    :view          the view, default is nil for no view. Passed as a parameter to
  355.                   document-corners and print-fn.
  356.  
  357.    :show-dialog?  display the print job dialog (default t)
  358.  
  359.    :local         default is t. If true, use the document coordinates while printing
  360.                   otherwise use coordinates within the page rectangle,
  361.                   by adjusting all coordinates by offset. 
  362.  
  363. |#
  364.  
  365. (export '(picture-hardcopy print-contents page-setup get-printer-error page-size))
  366. (provide 'print-u)
  367. ;; prepare to redefine the function get-prec by a standard generic function
  368. (when (and (fboundp 'get-prec) 
  369.        (equal (type-of #'get-prec) 'function))
  370.      (fmakunbound 'get-prec)
  371.      (setq *save-exit-functions*
  372.        (remove 'remove-prec *save-exit-functions* :key #'function-name)))
  373.  
  374. #-mcl-final 
  375. (eval-when (eval compile) 
  376.   (require :quickDraw))
  377. #+mcl-final
  378. (eval-when (eval compile) 
  379.   (ccl::require-interface :printTraps)
  380.   (require :quickDraw)
  381.   (require :loop)                       ; loop is automatically included in MCL 2.0f
  382.   )
  383.  
  384.  
  385. ;; Routines from quickdraw-u.lisp from Michael S. Engber
  386. ;;     Copyright  1991 Northwestern University Institute for the Learning Sciences
  387. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  388.  
  389. ;; the following macros are standard in MCL2.0 final
  390. #+mcl-final 
  391. (eval-when (:compile-toplevel :load-toplevel :execute)
  392.   
  393.   (defmacro href (pointer accessor)
  394.     `(rref ,pointer ,accessor :storage :handle))
  395.   
  396.   (defmacro pref (pointer accessor)
  397.     `(rref ,pointer ,accessor :storage :pointer))
  398.   
  399.   (defmacro hset (pointer accessor thing)
  400.     `(rset ,pointer ,accessor ,thing :storage :handle))
  401.   
  402.   (defmacro pset (pointer accessor thing)
  403.     `(rset ,pointer ,accessor ,thing :storage :pointer))
  404.   )
  405.  
  406. (defmacro with-font-spec (font-spec &body body)
  407.   (if (and (listp font-spec) (every #'constantp font-spec))
  408.     (multiple-value-bind (ff ms) (font-codes font-spec)
  409.       `(with-font-codes ,ff ,ms ,@body))
  410.     (let ((ff (gensym))
  411.           (ms (gensym)))
  412.       `(multiple-value-bind (,ff ,ms) (font-codes ,font-spec)
  413.          (with-font-codes ,ff ,ms ,@body)))))
  414.  
  415. (defmacro with-pen-state ((&key pnLoc pnSize pnMode pnPat pnPixPat) &body body)
  416.   (let ((state (gensym)))
  417.     `(rlet ((,state :PenState))
  418.        (require-trap #_GetPenState :ptr ,state)
  419.        (unwind-protect
  420.          (progn
  421.            ,@(when pnLoc    `((require-trap #_MoveTo :long ,pnLoc)))
  422.            ,@(when pnSize   `((require-trap #_PenSize :long ,pnSize)))
  423.            ,@(when pnMode   `((require-trap #_PenMode :signed-integer ,pnMode)))
  424.            ,@(when pnPat    `((require-trap #_PenPat :ptr ,pnPat)))
  425.            ,@(when pnPixPat `((require-trap #_PenPixPat :ptr ,pnPixPat)))
  426.            ,@body)
  427.          (require-trap #_SetPenState :ptr ,state)))))
  428. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  429. ;; end of macros from quickdraw.lisp
  430.  
  431. #-mcl-final
  432. (defun set-page-range (prec pages-to-print)
  433.   ;; sets page range of the print job record from 1 to pages-to-print
  434.   (rset prec :tprint.prjob.iFstpage 1)
  435.   (rset prec :tprint.prjob.iLstpage pages-to-print))
  436. #+mcl-final
  437. (defun set-page-range (prec pages-to-print)
  438.   (hset prec :tprint.prjob.iFstpage 1)
  439.   (hset prec :tprint.prjob.iLstpage pages-to-print))
  440.  
  441. (defvar *printing* nil "Printing not in progress")
  442. (defvar *print-record-window* nil "window containg the view being printed")
  443. (defvar *mcl-get-print-record* #'get-print-record)
  444. (defparameter *debug* nil)              ;  for debugging only
  445. (defparameter *print-error* nil "The printing error in the form printer-condition")
  446. (defvar *print-hc-prec*)                ; the default print-record
  447.  
  448. (defmethod remove-view-from-window :after ((subview view))
  449.   (remove-print-rec subview))
  450.  
  451. ;; condition for printer errors
  452. (define-condition printer-condition (error)
  453.   (phase code cond)
  454.   (:report (lambda (condition stream)
  455.              (with-slots (phase code cond) condition
  456.                (if cond
  457.                  (format stream "Printer error ~s" cond)  
  458.                  (format stream "Printer error ~s in phase ~s" code phase))))))
  459.  
  460. ;; condition for a user-cancel for a print operation
  461. (define-condition user-cancel (printer-condition))
  462.  
  463.  
  464.  
  465. ;; functions for converting coordinates from one system to another
  466. (defun convert-offset (window container offset)
  467.   ;; If the container is a view, returns in window coordinates, 
  468.   ;; the point offset which is expressed in container coordinates
  469.   ;; Otherwise returns the offset.
  470.   (subtract-points 
  471.    (if container
  472.      (convert-coordinates #@(0 0) container window)
  473.      #@(0 0))
  474.    offset))
  475.  
  476. (defmethod window-view-corners ((self view) &optional (offset #@(0 0)))
  477.   ;; returns the coordinates of the view corners in window coordinates
  478.   ;; offset by offset
  479.   (let ((container (view-container self))
  480.         (window (view-window self)))
  481.     (multiple-value-bind (topLeft bottomRight)
  482.                          (view-corners self)
  483.       (setq offset (convert-offset window container offset))
  484.       (values (add-points topLeft offset) (add-points bottomRight offset)))))
  485.  
  486. (defmethod window-view-corners ((self dialog-item)  &optional (offset #@(0 0)))
  487.   ;; returns the coordinates of the view corners of a dialog item
  488.   ;; in window coordinates offset by offset
  489.   (let ((container (view-container self))
  490.         (window (view-window self)))
  491.     (multiple-value-bind (topLeft bottomRight)
  492.                          (view-corners self)
  493.       (setq offset (convert-offset window container offset))
  494.       (values (add-points topLeft offset) (add-points bottomRight offset)))))
  495.  
  496. ;;; Modified routines from print-utils.lisp for printing the contents of a views
  497. ;;; converted from MCL1.3.2
  498. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  499. ;;
  500. ;;hardcopy.lisp
  501. ;;
  502. ;;
  503. ;;copyright 1988-89 Apple Computer, Inc.
  504. ;;
  505. ;; defines a very basic printing routine for windows
  506. ;;
  507. ;; Code taken from Apple and Bill Kornfeld and played with a bit to get
  508. ;; something working.  Trying to change the wptr and
  509. ;; then doing a view-draw-contents fails --- LISP unexpectantly quits.
  510. ;; view-draw-contents without changing the window pointer
  511. ;; causes a print job to be sent to the printer but nothing comes out.
  512. ;; Using a print-contents function that just makes the appropriate 
  513. ;; calls seems to work ok. The basic print-contents
  514. ;; quickdraw functions for text, views and windows are defined here. 
  515. ;; Some extra print-contents functions for other items is defined in
  516. ;; odin-printing.lisp -- DEH 6/20/91
  517.  
  518. ;;;------------------ Printer constants----------------------------------------
  519. (defconstant $err-printer 94)
  520. (defconstant $err-printer-load 95)
  521. (defconstant $err-printer-start 97)
  522.  
  523. ;;;------------------ Routine for trapping printer errors----------------------
  524. (defun printer-ok (&optional (errnum $err-printer)
  525.                              &aux (print-error (#_prError)))
  526.   ;; Checks for a printer error for the last printer command
  527.   ;; If there was an error, sets *printing* to nil
  528.   ;;   and if there has not been a previous printing error
  529.   ;;   sets the *print-error* to `(,errnum ,error)
  530.   (if (zerop print-error)
  531.     t
  532.     (progn
  533.       (unless *print-error*
  534.         (setq *print-error* (make-condition 'printer-condition))
  535.         (setf (slot-value *print-error* 'phase) errnum
  536.               (slot-value *print-error* 'code) print-error
  537.               (slot-value *print-error* 'cond) nil))
  538.       (setq *printing* nil)
  539.       (signal 'user-cancel))))
  540.  
  541. (defmacro check-printer-ok (form &optional (errnum $err-printer))
  542.   "Checks that the printer is ok after the execution of the form"
  543.   `(progn
  544.      ,form
  545.      (if (printer-ok ,errnum)
  546.        t
  547.        (throw :cancel nil))))
  548.  
  549. (defun get-printer-error ()
  550.   ;; returns nil or the the last non-zero printer error 
  551.   *print-error*)
  552.  
  553. ;;;------------------ The basic print-contents functions-----------------------
  554. (defmethod print-contents ((v window) &optional (offset #@(0 0)))
  555.   "a window draws a box around itself and
  556.    then asks its subviews to print themselves"
  557.   ;;first frame it
  558.   (multiple-value-bind (top-left bottom-right)
  559.                        (window-view-corners v offset)
  560.     (ccl::with-rectangle-arg (r top-Left bottom-right) 
  561.       (#_FrameRect r)))
  562.   (dovector (sv (view-subviews v))
  563.     (print-contents sv offset)))
  564.  
  565. (defmethod print-contents ((v view) &optional (offset #@(0 0)))
  566.   "a view just asks its subviews to print themselves"
  567.     (dovector (sv (view-subviews v))
  568.       (print-contents sv offset)))
  569.  
  570. (defmethod print-contents ((sv ccl::basic-editable-text-dialog-item)
  571.                            &optional (offset #@(0 0)))
  572.   "editable text uses textbox -- takes into account font and the justification"
  573.     (multiple-value-bind (top-left bottom-right)
  574.                          (window-view-corners sv offset)
  575.     (with-font-spec (view-font sv)
  576.       (ccl::with-rectangle-arg (r top-Left bottom-right)
  577.         (with-pstrs ((pstring (dialog-item-text sv)))
  578.           (#_TextBox :ptr (%inc-ptr pstring 1)
  579.            :long (length (dialog-item-text sv))
  580.            :ptr r
  581.            :word (slot-value sv 'ccl::text-justification)))))))
  582.  
  583. (defmethod print-contents ((sv static-text-dialog-item) &optional (offset #@(0 0)))
  584.   "static text uses textbox -- take into account font and the justification"
  585.   (multiple-value-bind (top-left bottom-right)
  586.                        (window-view-corners sv offset)
  587.     (with-font-spec (view-font sv)
  588.       (ccl::with-rectangle-arg (r top-Left bottom-right)
  589.         (with-pstrs ((pstring (dialog-item-text sv)))
  590.           (#_TextBox :ptr (%inc-ptr pstring 1)
  591.            :long (length (dialog-item-text sv))
  592.            :ptr r
  593.            :word (slot-value sv 'ccl::text-justification)))))))
  594.  
  595. (defmethod print-contents ((sv button-dialog-item)  &optional (offset #@(0 0)))
  596.   (multiple-value-bind (top-left bottom-right)
  597.                        (window-view-corners sv offset)
  598.     (ccl::with-rectangle-arg (r top-left bottom-right)
  599.       (with-font-spec (view-font sv)
  600.         (with-pstrs ((pstring (dialog-item-text sv)))
  601.           (#_TextBox :ptr (%inc-ptr pstring 1)
  602.            :long (length (dialog-item-text sv))
  603.            :ptr r :word 1)))
  604.       ;;; end of with-font-spec
  605.       (with-pen-state (:pnSize #@(1 1)
  606.                                :pnMode #$PATOR
  607.                                :pnPat *black-pattern*)
  608.           (decf (rref r :rect.left)
  609.                 (floor (dialog-item-width-correction sv) 2))
  610.           (incf (rref r :rect.right)
  611.                 (floor (dialog-item-width-correction sv) 2))
  612.           (#_FrameRoundRect :ptr r :word 10 :word 6)))))
  613.  
  614. (defmethod print-contents ((sv simple-view) &optional offset)
  615.   (declare (ignore offset))
  616.   "default if all else fails do nothing"
  617.   t)
  618. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  619. ;;; End of modified routines from print-utils.lisp
  620.  
  621. ;;;------------------ handles - checking validity and removing -------------------
  622. (defun valid-handle (handle)
  623.   (when (and handle
  624.              (handlep handle)
  625.              (pointerp handle)
  626.              (macptrp handle)
  627.              (not (equal handle (%null-ptr))))
  628.     handle))
  629.  
  630. (defun dispose-handle (handle)
  631.   (when (valid-handle handle)
  632.       (#_disposeHandle handle)))
  633.  
  634. ;;;---------retrieving and changing the value of an internal print-record---------
  635. ;; routines do not allocate new print records 
  636. (defmethod prec-get ((self view))
  637.   (view-get self :prec))
  638.  
  639. (defmethod prec-put ((self view) value)
  640.   (view-put self :prec value))
  641.  
  642. (defmacro clean-catch-cancel (flag &body body)
  643.   ;; When debugging print the flag
  644.   ;; Execute the body unwind-protected while catching
  645.   ;; cancels, errors, aborts and breaks
  646.   (let ((old-state (gensym)))
  647.    `(let ((,old-state *break-on-errors*))
  648.      (unwind-protect
  649.       (handler-case
  650.        (restart-case
  651.          (catch :cancel
  652.            (when *debug* (format t "~&--->~a~%" ,flag))
  653.            (setq *break-on-errors* nil)
  654.            ,@body)
  655.          (abort () (message-dialog "Printing aborted.")
  656.                 (stop-printing))
  657.          (error (condition) (stop-printing condition)))
  658.        (error (condition) (setq *printing* nil) condition))
  659.       (setq *break-on-errors* ,old-state)))))
  660.  
  661. ;;;---------determining the window containing the view (if any)---------
  662. ;;  for views returns
  663. ;;    either the window containing the view
  664. ;;    or the outermost view containing the view
  665. ;;  for all other objects returns the object
  666.  
  667. (defmethod containing-window (window)
  668.   window)
  669.  
  670. (defmethod containing-window ((sub-view view))
  671.   (loop with new-view
  672.         do (setq new-view (view-container sub-view))
  673.         while new-view
  674.         do (setq sub-view new-view)
  675.         finally (return sub-view)))
  676.  
  677. (defmethod containing-window ((self t))
  678.   self)
  679.  
  680. ;;;---------allocating, modifying and updating the internal print records---------
  681. (defmethod remove-print-rec ((subview view))
  682.   (let ((view-print-record (view-get subview :prec)))
  683.     (dispose-handle view-print-record)
  684.     (view-put subview :prec nil)))
  685.  
  686. ;; file names associated with views
  687. (defmethod view-file-name ((window fred-window))
  688.   (slot-value window 'ccl::my-file-name))
  689.  
  690. (defmethod view-file-name (view)
  691.   (declare (ignore view))
  692.   nil)
  693.  
  694. (defmethod view-file-name ((self t))
  695.   nil)
  696.  
  697. ;;;---------manipulating the internal print records---------
  698. (defmethod remove-prec ((subview view))
  699.   ;; clean up the internal tprint handle (if any)
  700.   (dispose-handle (prec-get subview))
  701.   (prec-put subview nil))
  702.  
  703. (defmethod check-prec ((self view))
  704.   ;; gets the tprint handle and validates it 
  705.   ;; when successful, returns the tprint handle
  706.   ;; must be called when the printer is open (e.g. within with-printer-open)
  707.   (let ((local-prec (get-print-prec self)))
  708.     (when local-prec
  709.       (clean-catch-cancel 
  710.        :check-print
  711.        (check-printer-ok (#_prValidate :ptr local-prec :boolean))
  712.        local-prec))))
  713.  
  714. (defmethod update-file-prec ((self view) prec &optional file-name)
  715.   ;; Saves a copy of the internal print record as a resource. 
  716.   ;; Called during a page setup and after saving a file (in this
  717.   ;; case the file-name argument is supplied 
  718.   (let ((filename (or file-name (view-file-name self)))
  719.         new-prec
  720.         old-prec)
  721.     (when (valid-handle prec)
  722.       (when (pathnamep filename)
  723.         (with-open-resource-file (refnum filename :if-does-not-exist :create)
  724.           (when *debug* (print-record prec :tprint) (terpri))
  725.           (setq old-prec (get-resource :prec 128 :errorp nil))
  726.           (when (valid-handle old-prec)
  727.             (remove-resource old-prec)
  728.             (dispose-handle old-prec))
  729.           (setq new-prec (copy-handle prec))
  730.           (when *debug* (print-record prec :tprint) (terpri))
  731.           ;; from Inside Macintosh I-123
  732.           (#_HNoPurge new-prec)
  733.           (add-resource new-prec :prec 128) 
  734.           (#_changedResource new-prec)
  735.           (write-resource new-prec)
  736.           (#_HPurge new-prec)
  737.           new-prec)))))
  738.  
  739. (defmethod update-file-prec ((self t) prec  &optional file-name)
  740.   (declare (ignore prec file-name))
  741.   t)
  742.  
  743. (defmethod get-prec ((self view))
  744.   (let (printer-record
  745.         (file-name (view-file-name self))
  746.         (view-print-record (prec-get self))
  747.         create)
  748.     ;; retrieves and possibly initializes the private print record
  749.     ;; if the print record exists and is a valid handle
  750.     ;;   returns the handle
  751.     ;; otherwise initializes the private print record
  752.     ;;   tries to read the :prec resource from the view-file-name
  753.     ;;    if successful
  754.     ;;     stores and returns a copy of the resource (handle)  
  755.     ;;    otherwise
  756.     ;;     creates a default print record using default-prec
  757.     ;;  
  758.     (cond 
  759.      ((valid-handle view-print-record) view-print-record)
  760.      ((null (pathnamep file-name)) (create-default-prec self))
  761.      (t (with-open-resource-file (refnum file-name :if-does-not-exist nil)
  762.           (cond 
  763.            ((or (null refnum) 
  764.                 (null (setq printer-record (get-resource :prec 128 :errorp nil))))
  765.             (setq view-print-record (create-default-prec self)
  766.                   create t))
  767.            (t (remove-prec self)
  768.               (setq view-print-record (copy-record printer-record :tprint))
  769.               (prec-put self view-print-record)))
  770.           (when create
  771.             (update-file-prec self view-print-record))
  772.           view-print-record)))))
  773.  
  774. (defmethod create-default-prec ((self view))
  775.   (let (view-print-record)
  776.     (remove-prec self)
  777.     (setq view-print-record (default-prec self))
  778.     (prec-put self view-print-record)
  779.     (update-file-prec self view-print-record)
  780.     view-print-record))
  781.  
  782. (defmethod get-prec ((self t))
  783.   ;; attempts to retrieve the global *print-hc-prec* tprint handle
  784.   ;; if the variable has not been initialized or is invalid
  785.   ;;   attempts to allocate a new tprint handle and assign it *print-hc-prec*
  786.   ;; returns the handle if successful, otherwise returns nil
  787.   ;;  
  788.   (let (code)
  789.     (unless (and (boundp '*print-hc-prec*)
  790.                  (valid-handle *print-hc-prec*))
  791.       (clean-catch-cancel 
  792.        :prec
  793.        (setq *print-hc-prec* (#_NewHandle :errchk (record-length :TPrint)))
  794.        (setq code (#_MemError))
  795.        (when (zerop code)
  796.          (if (not (handlep *print-hc-prec*))
  797.            (setq code "invalid-handle")
  798.            (progn
  799.              (check-printer-ok (#_PrintDefault :ptr *print-hc-prec*))
  800.              (setq code nil))))))
  801.     (unless code
  802.       *print-hc-prec*)))
  803.  
  804. (defmethod get-print-prec ((sub-view view))
  805.   (let ((outer-container (containing-window sub-view)))
  806.     (cond ((eq sub-view outer-container) (get-prec sub-view))
  807.           (outer-container (get-prec outer-container))
  808.           (t (get-prec t)))))
  809.  
  810. ;; create a default print-record
  811. (defmethod default-prec ((self view))
  812.   (let (code
  813.         view-print-record)
  814.     (clean-catch-cancel 
  815.       :prec
  816.       (remove-prec self)
  817.       (setq view-print-record (#_NewHandle :errchk (record-length :TPrint)))
  818.       (setq code (#_MemError))
  819.       (when (zerop code)
  820.         (prec-put self view-print-record)
  821.         (if (not (valid-handle view-print-record))
  822.           (setq code "invalid-handle"
  823.                 view-print-record (remove-prec self))
  824.           (progn
  825.             (prec-put self view-print-record)
  826.             (check-printer-ok (#_PrintDefault :ptr view-print-record))
  827.             (setq code nil)))))
  828.     (unless code
  829.       view-print-record)))
  830.  
  831. ;; routines for allocating/deallocating the tprint handle for printing
  832.  
  833. (defun stop-printing (&optional condition)
  834.   ;; stop printing
  835.   (setq *printing* nil
  836.         *print-error* (make-condition 'printer-condition))
  837.   (if condition
  838.     (setf (slot-value *print-error* 'phase) nil
  839.           (slot-value *print-error* 'code) nil
  840.           (slot-value *print-error* 'cond) condition)
  841.     (setf (slot-value *print-error* 'phase) $err-printer
  842.           (slot-value *print-error* 'code) #$iPrAbort
  843.           (slot-value *print-error* 'cond) nil))
  844.   (#_PrSetError #$iPrAbort)
  845.   (error *print-error*))
  846.  
  847. (defun reset-printing ()
  848.   (setq *printing* nil)
  849.   (#_prSetError #$NoErr))
  850.  
  851.  
  852. ;; default method for getting a print record and saving in *print-hc-prec*
  853. ;; specialize if you want to store the tprint record with a window.
  854. (defmethod get-print-prec ((self t))
  855.   ;; attempts to retrieve the *print-hc-prec* tprint handle
  856.   ;; if the variable has not been initialized or is invalid
  857.   ;;   attempts to allocate a new tprint handle and assign it *print-hc-prec*
  858.   ;; returns the handle if successful, otherwise returns nil
  859.   ;;  
  860.   (let (code)
  861.     (unless (and (boundp '*print-hc-prec*)
  862.                  *print-hc-prec*
  863.                  (pointerp *print-hc-prec*)
  864.                  (macptrp *print-hc-prec*)
  865.                  (handlep *print-hc-prec*))
  866.       (clean-catch-cancel 
  867.        :prec
  868.        (setq *print-hc-prec* (#_NewHandle :errchk (record-length :TPrint)))
  869.        (setq code (#_MemError))
  870.        (when (zerop code)
  871.          (if (not (handlep *print-hc-prec*))
  872.            (setq code "invalid-handle")
  873.            (progn
  874.              (check-printer-ok (#_PrintDefault :ptr *print-hc-prec*))
  875.              (setq code nil))))))
  876.     
  877.     (unless code
  878.       *print-hc-prec*)))
  879.  
  880. ;; the method for getting a fred print record
  881. (defmethod get-print-prec ((window fred-window))
  882.   (get-print-record))
  883.  
  884. (defun check-print-prec (view)
  885.   ;; gets the tprint handle and validates it 
  886.   ;; when successful, returns the tprint handle
  887.   ;; must be called when the printer is open (e.g. within with-printer-open)
  888.   (let ((local-prec (get-print-prec view)))
  889.     (when local-prec
  890.       (clean-catch-cancel 
  891.        :check-print
  892.        (check-printer-ok (#_prValidate :ptr local-prec :boolean))
  893.        local-prec))))
  894.  
  895. ;; the print status dialog box (print-dialog) displayed when printing in progress.
  896. (defclass print-dialog (window)
  897.   ()
  898.   (:default-initargs
  899.     :window-type :double-edge-box 
  900.     :view-position :centered 
  901.     :view-size #@(373 96) 
  902.     :close-box-p nil 
  903.     :view-font '("Chicago" 12 :srcor :plain)))
  904.  
  905. (defmethod initialize-instance ((window print-dialog) &rest initargs)
  906.   (apply #'call-next-method window initargs)
  907.   (add-subviews window
  908.                 (make-instance 'static-text-dialog-item
  909.                   :view-position #@(10 10)
  910.                   :view-size #@(151 40) 
  911.                   :dialog-item-text (format nil
  912.                                             "Printing in progress
  913. To cancel press ~a-." #\CommandMark)
  914.                   :view-nick-name 'title)
  915.                 
  916.                 (make-instance 'static-text-dialog-item 
  917.                   :view-position #@(10 72) 
  918.                   :view-size #@(120 18) 
  919.                   :dialog-item-text "Printing page")
  920.                 
  921.                 (make-instance 'static-text-dialog-item 
  922.                   :view-position #@(135 72) 
  923.                   :view-size #@(36 18) 
  924.                   :dialog-item-text ""
  925.                   :view-nick-name 'page)
  926.                 
  927.                 #|
  928. (make-instance 'button-dialog-item 
  929.   :view-position #@(302 72) 
  930.   :view-size #@(62 16) 
  931.   :dialog-item-text "Cancel" 
  932.   :dialog-item-action 
  933.   #'(lambda (item) item
  934.      (window-hide (view-window item))
  935.      (stop-printing)) 
  936.   :default-button nil)
  937. |#
  938.                 ))
  939.  
  940. (defvar *print-dialog*
  941.   (make-instance 'print-dialog :window-show nil)
  942.   "The printing progress dialog box")
  943.  
  944. ;; gets the dialog box asscoiated with print progress
  945. (defmethod get-print-dialog ((self t) &key (display nil) (wait t))
  946.   (declare (ignore self))
  947.   "Displays the printer progress dialog box and waits for 1 second."
  948.   (unless (and *print-dialog* (wptr *print-dialog*) (pointerp (wptr *print-dialog*)))
  949.     (setq *print-dialog* (make-instance 'print-dialog :window-show nil)))
  950.   (when (and *printing* display) 
  951.     (with-focused-view *print-dialog*
  952.       (window-show *print-dialog*)))
  953.   (when wait (sleep 1))
  954.   *print-dialog*)
  955.  
  956. ;; default method for removing the print progress dialog box, 
  957. ;; specialize for other views
  958. (defmethod remove-print-dialog ((self t))
  959.   (when (and *print-dialog* (wptr *print-dialog*))
  960.     (window-close *print-dialog*))
  961.   (setq *print-dialog* nil))
  962.  
  963. ;; default method for indicating printing progress, specialize for other views
  964. ;; Note: does not update the page field when background printing is off
  965. (defmethod set-page-number ((self t) page-no &key (display nil))
  966.   "Update the page number field for printing"
  967.   (let* ((print-dialog (get-print-dialog self :display display :wait display))
  968.          (page-field (view-named 'page print-dialog)))
  969.     ; force the window to be updated
  970.     (with-focused-view print-dialog
  971.       (set-dialog-item-text page-field (format nil "~3d" page-no))
  972.       ;(event-dispatch)    ; fails to return when background printing is off
  973.       (sleep 1))))            
  974.  
  975. ;; methods and functions for working with the printer port as a view
  976. ;;  similar to the wmgr-view functions in oodles-of-utils:simple-view-ce.lisp
  977. ;; Supplied by Bill St. Clair at Apple.
  978.  
  979. (defclass printer-view (simple-view)
  980.   ((clip-region :initform nil :accessor printer-view-clip-region)))
  981.  
  982. (defmethod view-origin ((view printer-view))
  983.   (let ((wptr (wptr view)))
  984.     (if wptr
  985.       (rref wptr :grafport.portrect.topleft)
  986.       #@(0 0))))
  987.  
  988. (defmethod view-clip-region ((view printer-view))
  989.   (let ((macptr (printer-view-clip-region view)))
  990.     (unless (typep macptr 'macptr)
  991.       (setq macptr
  992.             (setf (printer-view-clip-region view) (%null-ptr))))
  993.     (%setf-macptr macptr (rref (wptr view) :grafport.cliprgn))
  994.     macptr))
  995.  
  996. (defun make-printer-view (printer-port)
  997.   (let ((topleft (rref printer-port :grafport.portrect.topleft))
  998.         (botright (rref printer-port :grafport.portrect.botright)))
  999.     (make-instance 'printer-view
  1000.       :wptr printer-port
  1001.       :view-position topleft
  1002.       :view-size (subtract-points botright topleft))))
  1003.  
  1004. ;;  basic macros for using a printer, printing a document and printing a page.
  1005. (defmacro with-open-page ((hardcopy-ptr page-size offset &key (local t))
  1006.                           &rest body)
  1007.   ;; Opens a printer page
  1008.   ;; executes the body
  1009.   ;; closes the printer upon termination (even when in error)
  1010.   ;; returns the result of executing the body
  1011.   (let ((r (gensym))
  1012.         (vals (gensym)))
  1013.     `(let (,vals)
  1014.        (clean-catch-cancel 
  1015.         :open-page
  1016.         (rlet ((,r :rect :topLeft #@(0 0) :bottomRight ,page-size))
  1017.           (when ,local (#_offsetRect :ptr ,r :long ,offset))
  1018.           (unwind-protect
  1019.             (clean-catch-cancel 
  1020.              :inner-open-page
  1021.              (setq ,vals
  1022.                    (multiple-value-list
  1023.                     (with-clip-rect ,r 
  1024.                       (check-printer-ok 
  1025.                        (#_PrOpenPage :ptr ,hardcopy-ptr :ptr (if ,local ,r  (%null-ptr))))
  1026.                       ,@body))))
  1027.             (check-printer-ok (#_PrClosePage :ptr ,hardcopy-ptr)))))
  1028.        (values-list ,vals))))
  1029.  
  1030. (defmacro with-open-doc (hardcopy-ptr prec &rest body)
  1031.   ; _PrOpenDoc puts up a dialog window
  1032.   ; In order to process events within the body, we must call
  1033.   ; event-dispatch, otherwise windows will not be updated
  1034.   ; Opens the printer document
  1035.   ; Executes the body of code with the local variable
  1036.   ;   hardcopy-ptr bound to the printer GrafPort
  1037.   ;   prec is a handle to the TPrint record
  1038.   ; Closes the printer document upon termination (even when in error)
  1039.   ; Returns the result of executing the body
  1040.   ;;
  1041.   ; without-interrupts appears in the same place as (window-hardcopy fred-window)
  1042.   ; before the open-doc (decinest appears at location 332, open-doc at 360-362)
  1043.   (let ((vals (gensym))
  1044.         (stRec (gensym))
  1045.         (printer-view (gensym)))
  1046.     `(let ((,hardcopy-ptr 
  1047.             (#_PrOpenDoc :ptr ,pRec :ptr (%null-ptr) :ptr (%null-ptr) :ptr))
  1048.            ,vals
  1049.            ,printer-view)
  1050.        (without-interrupts
  1051.         (clean-catch-cancel 
  1052.           :open-doc
  1053.           (unwind-protect
  1054.             (clean-catch-cancel 
  1055.               :port
  1056.               (setq ,printer-view (make-printer-view ,hardcopy-ptr))
  1057.               (check-printer-ok nil $err-printer-start)
  1058.               (setq ,vals
  1059.                     (multiple-value-list
  1060.                      (with-focused-view ,printer-view 
  1061.                        ,@body))))
  1062.             (check-printer-ok (#_PrCloseDoc :ptr ,hardcopy-ptr)))
  1063.           (when (= (href ,prec :tprint.prJob.bjDocLoop) #$bSpoolLoop)
  1064.             (%stack-block ((,StRec (record-length :tprStatus)))
  1065.               (check-printer-ok (#_PrPicFile
  1066.                                  :ptr ,pRec
  1067.                                  :ptr (%null-ptr)
  1068.                                  :ptr (%null-ptr)
  1069.                                  :ptr (%null-ptr)
  1070.                                  :ptr ,StRec)))))
  1071.         (values-list ,vals)))))
  1072.  
  1073. (defmacro with-open-printer ((prec &key view (show-dialog? nil)) &rest body)
  1074.   ; Opens the printer
  1075.   ; Executes the body of code with the local variable
  1076.   ;  Closes the printer upon termination (even when in error)
  1077.   ;; returns the result of executing the body
  1078.   
  1079.   (let ((vals (gensym)))
  1080.     `(let (,vals ,prec)
  1081.        (unwind-protect
  1082.          (clean-catch-cancel 
  1083.           :open-print
  1084.           (setq ,vals
  1085.                 (multiple-value-list
  1086.                  (unless *printing*
  1087.                    (check-printer-ok (#_PrOpen) $err-printer-load)
  1088.                    (setq *printing* t)
  1089.                    (when (and (setq ,prec (check-print-prec ,view))
  1090.                               (or (null ,show-dialog?) 
  1091.                                   (with-cursor *arrow-cursor* 
  1092.                                     (#_PrJobdialog :ptr ,prec :boolean))))
  1093.                      ,@body)))))
  1094.          (check-printer-ok (#_PrClose))
  1095.          (setq *printing* nil))
  1096.        (values-list ,vals))))
  1097.  
  1098. ;; generalized page-setup routines for objects that are not fred windows
  1099. (defmethod page-setup ((self t))
  1100.   ;; Atempts to retrieve a valid tprint handle
  1101.   ;; If successful displays the page setup dialog using the print record
  1102.   ;; Returns t when successful
  1103.   (with-cursor *arrow-cursor*
  1104.     (with-open-printer (prec :view self)
  1105.       (when *debug* (print-record prec :tprint) (terpri))
  1106.       (check-printer-ok (#_PrStlDialog :ptr prec :boolean))
  1107.       (update-file-prec self prec)
  1108.       (when *debug* (print-record prec :tprint) (terpri))
  1109.       t)))
  1110.  
  1111. ;; page setup
  1112. ;;   for fred windows
  1113. (defmethod page-setup ((window fred-window))
  1114.   (let ((*print-record-window* window))
  1115.     (print-style-dialog)))
  1116.  
  1117. ;; routines for determining the topLeft and bottomRight corners
  1118. ;; of the printer-page
  1119. (defun get-page-size (pRec)
  1120.   (subtract-points (href pREC :tprint.prInfo.rpage.bottomRight)
  1121.                    (href pREC :tprint.prInfo.rpage.topLeft)))
  1122.  
  1123. (defmethod page-size ((self t))
  1124.   (with-open-printer (prec :view self)
  1125.     (get-page-size prec)))
  1126.  
  1127. (defmethod page-size ((window fred-window))
  1128.   (with-open-printer (prec :view window)
  1129.     (get-page-size prec)))
  1130.      
  1131. ;; Routines for computing the corners of rectangular pictures and windows
  1132.  
  1133. (defun picture-corners (picture page-size)
  1134.   (declare (ignore page-size))
  1135.   ;; return the topleft and bottomRight corners of the picture
  1136.   (when (handlep picture)
  1137.     (values
  1138.      (rref picture picture.picframe.topleft)
  1139.      (rref picture picture.picframe.bottomRight))))
  1140.  
  1141. (defmethod window-document-corners ((view window) page-size)
  1142.   (declare (ignore page-size))
  1143.   ;; Computes the topLeft and bottomRight corners of the rectangle
  1144.   ;; for the view. Specialize to handle scrolling windows
  1145.   (view-corners view))
  1146.  
  1147. (defmethod view-document-corners ((view view) page-size)
  1148.   (declare (ignore page-size))
  1149.   ;; Computes the topLeft and bottomRight corners of the rectangle
  1150.   ;; for the view. Specialize to handle scrolling windows
  1151.   (view-corners view))
  1152.  
  1153. ;; routines for computing the page layout (document size in pages-h x pages-v)
  1154. (defun compute-page-size (document-size page-size)
  1155.   ;; returns the point representing the document-size in pages width x depth
  1156.   (let* ((page-h (ceiling (point-h document-size) (point-h page-size)))
  1157.          (page-v (ceiling (point-v document-size) (point-v page-size))))
  1158.     (values
  1159.      page-h
  1160.      page-v
  1161.      (* page-h page-v))))
  1162.  
  1163. ;; not currently used, can be used within the print-fn for a document-hardcopy
  1164. ;; to determine the current page number, and row/column index
  1165. (defun compute-page-topLeft (page-size pages-h pages-v page-no)
  1166.   ;; given the size of the page-rectangle (page-size)
  1167.   ;;       the dimensions of the document in pages pages-h x pages-v
  1168.   ;;       the page number being printed
  1169.   ;; returns the page-no and the column/row position of the page
  1170.   ;;       and the coordinates of the upper left corner of the
  1171.   ;;       document corresponding to the page of size page-size
  1172.   (declare (ignore pages-v))
  1173.   (multiple-value-bind (real-v real-h)
  1174.                        (truncate page-no pages-h)
  1175.     (values
  1176.      page-no
  1177.      real-h
  1178.      real-v
  1179.     (make-point (* (point-h page-size) real-h)
  1180.                 (* (point-v page-size) real-v)))))
  1181.  
  1182. ;; default routines for printing a document and for determining its size
  1183. (defun default-document-hardcopy (view page-size page-no offset local)
  1184.   (declare (ignore view prRec page-size page-no offset local)))
  1185.  
  1186. (defun default-document-corners (view psize)
  1187.   (declare (ignore view))
  1188.   (values #@(0 0) psize))
  1189.  
  1190. (defun compute-page-layout (view page-size compute-doc-size)
  1191.   ;; uses the compute-doc-size function with view and page-size
  1192.   ;; to compute the size of the document in pages (pages-h x pages-v)
  1193.     (multiple-value-bind (top bottom)
  1194.                          (funcall (if (functionp compute-doc-size)
  1195.                                     compute-doc-size
  1196.                                     #'ccl::default-document-corners)
  1197.                                   view page-size)
  1198.       (compute-page-size (subtract-points bottom top) page-size)))
  1199.  
  1200.  
  1201. ;; hardcopy routines for documents, windows and pictures
  1202.  
  1203. ;;  General hardcopy routine
  1204. (defun document-hardcopy (print-fn document-corners &key (show-dialog? t) view (local t))
  1205.   (setq *print-error* nil)
  1206.   (let (offset 
  1207.         page-size v-dim h-dim (page-no 0))
  1208.     (get-print-dialog view)
  1209.     (with-cursor *arrow-cursor* 
  1210.       (with-open-printer (prec :view view :show-dialog? show-dialog?)
  1211.         (with-cursor *watch-cursor*
  1212.           (when *printing*
  1213.             (clean-catch-cancel 
  1214.              :doco
  1215.               (unwind-protect
  1216.                 (setq page-size (get-page-size prec))
  1217.                 (multiple-value-bind (pages-h pages-v pages)
  1218.                                      (compute-page-layout view page-size document-corners)
  1219.                   (print-db
  1220.                    (decf pages-h)
  1221.                    (decf pages-v)
  1222.                    (unless (functionp print-fn)
  1223.                      (setq print-fn #'default-document-hardcopy))
  1224.                    (window-select (get-print-dialog view :display t))
  1225.                    (event-dispatch))
  1226.                   (with-open-doc hardcopy-ptr prec
  1227.                     (let* ((from-page (max 1 (href prec :tprint.prJob.iFstPage)))
  1228.                            (to-page (min pages (href prec :tprint.prJob.iLstPage)))
  1229.                            (pages-to-print (1+ (- to-page from-page))))
  1230.                       ;; print pages-to-print pages (from from-page to to-page)
  1231.                       ;; adjust the print record to print only pages-to-print pages
  1232.                       (set-page-range prec pages-to-print)
  1233.                       (loop for v-page fixnum from 0 to pages-v
  1234.                             do (setq v-dim (* (point-v page-size) v-page))
  1235.                             (loop for h-page fixnum from 0 to pages-h
  1236.                                   do (incf page-no)
  1237.                                   (when (<= from-page page-no to-page)
  1238.                                     ;; only print pages in the range from-page to to-page
  1239.                                     (decf pages-to-print)
  1240.                                     (setq h-dim (* (point-h page-size) h-page))
  1241.                                     (setq offset (make-point h-dim v-dim))
  1242.                                     (when *printing*
  1243.                                       (set-page-number view page-no :display t)
  1244.                                       (with-open-page (hardcopy-ptr page-size offset :local local)
  1245.                                         (funcall print-fn view page-size page-no offset local))))
  1246.                                   
  1247.                                   while (and *printing*   ; stop when printing canceled
  1248.                                              (> pages-to-print 0)))   ; or no pages to print
  1249.                             
  1250.                             ; stop when no pages remain to print or printing is cancelled
  1251.                             while (and *printing* (> pages-to-print 0)))))))))
  1252.           (unless *printing* 
  1253.             (unless *print-error*
  1254.               (setq *print-error* (make-condition 'printer-condition))
  1255.               (with-slots (phase code cond) *print-error*
  1256.                 (setq phase $err-printer
  1257.                       code #$iPrAbort
  1258.                       cond nil))
  1259.               (#_PrSetError #$iPrAbort)))
  1260.           (remove-print-dialog view)
  1261.           (setq *printing* nil)
  1262.           (null *print-error*))))))
  1263.  
  1264. ;; Internal routine for printing the contents of a views
  1265. (defmethod view-print-contents ((subview view)
  1266.                                 page-size page-no offset local)
  1267.   (declare (ignore page-size page-no))
  1268.   (let ((*print-record-window* subview))
  1269.     (print-contents subview (if local #@(0 0)
  1270.                                 offset))))
  1271.  
  1272. ;; Print contents of a non-fred window, fred windows already defined
  1273. (defmethod window-hardcopy ((v window) &optional (show-dialog? t))
  1274.   (document-hardcopy #'view-print-contents #'window-document-corners
  1275.                      :view  v
  1276.                      :show-dialog? show-dialog?
  1277.                      :local t))
  1278.  
  1279. ;; Print a picture on the printer
  1280. (defun picture-hardcopy (picture &optional (show-dialog? t))
  1281.   (when (handlep picture)
  1282.     (with-dereferenced-handles ((picture-ptr picture))
  1283.       (flet ((pict-draw (view page-size page-no offset local)
  1284.                (declare (ignore view page-no))
  1285.                (multiple-value-bind (topLeft bottomRight)
  1286.                                     (picture-corners picture page-size)
  1287.                  (with-rectangle-arg (r topLeft bottomRight)
  1288.                    (unless local (#_offsetRect :ptr r :long (subtract-points #@(0 0) offset)))
  1289.                    (#_drawPicture :ptr picture :ptr r))))
  1290.              (pict-size (view page-size)
  1291.                (declare (ignore view))
  1292.                (picture-corners picture page-size)))
  1293.         (declare (dynamic-extent #'pict-draw #'pict-size))
  1294.         (document-hardcopy #'pict-draw #'pict-size :show-dialog? show-dialog?)))))
  1295.  
  1296. ;;;; functions to setup the environment for printing
  1297. ;; changes the page setup menu item to use the new Page Setup function
  1298. (defun fix-file-menu ()
  1299.   (let ((page-setup (find-menu-item *file-menu* "Page Setup"))
  1300.         (print (find-menu-item *file-menu* "Print")))
  1301.     (when page-setup
  1302.       (change-class page-setup 'window-menu-item)
  1303.       (setf (menu-item-action-function page-setup)
  1304.             #'(lambda (window)
  1305.                 (eval-enqueue `(page-setup ,window)))))
  1306.     (when print
  1307.       (setf (menu-item-action-function print)
  1308.             #'(lambda (window)
  1309.                 (eval-enqueue `(ccl::window-hardcopy ,window)))))
  1310.     (setq *printing* nil)))
  1311.  
  1312. (defun remove-hc-prec ()
  1313.   ;; clean up the internal tprint handle
  1314.   ;; modify if you need to clean up others
  1315.   (when (and (boundp '*print-hc-prec*)
  1316.              (macptrp *print-hc-prec*)
  1317.              (handlep *print-hc-prec*))
  1318.     (#_disposeHandle *print-hc-prec*)
  1319.     (makunbound '*print-hc-prec*)))
  1320.                 
  1321. (defun setup-printing ()
  1322.   ;; remove and then add #'fix-file-menu to end of *lisp-startup-functions*
  1323.   (setq *lisp-startup-functions*
  1324.         (remove 'fix-file-menu *lisp-startup-functions* :key #'function-name))
  1325.   (setq *printing* nil)
  1326.   (push #'fix-file-menu *lisp-startup-functions*)
  1327.   (setq *save-exit-functions*
  1328.         (remove 'remove-hc-prec *save-exit-functions* :key #'function-name))
  1329.   (push #'remove-hc-prec *save-exit-functions*))
  1330.   
  1331. ;; setup the printing enviroment and fix the Page setup menu item
  1332. (setup-printing)
  1333. (fix-file-menu)
  1334.  
  1335. ;; augment the window-hardcopy, window-save, print-style-dialog
  1336. ;; and get-print-record routines
  1337. (advise ccl::window-hardcopy
  1338.         (let* ((*print-record-window* (car arglist))
  1339.                (*hc-prec* (with-open-printer (prec :view *print-record-window*)
  1340.                             (get-print-prec *print-record-window*))))
  1341.           (:do-it))
  1342.         :when :around)
  1343.  
  1344. (advise ccl::window-save-file
  1345.         (let ((*print-record-window* (car arglist))
  1346.               window-file)
  1347.           (setq window-file (:do-it))
  1348.           (when window-file
  1349.             (with-open-printer (prec :view *print-record-window*)
  1350.               (get-print-prec *print-record-window*)
  1351.               (update-file-prec *print-record-window* 
  1352.                            (get-prec *print-record-window*)
  1353.                            window-file)))
  1354.           window-file)
  1355.         :when :around)
  1356.  
  1357. (advise ccl::print-style-dialog
  1358.         (let ((*print-record-window* (front-window))
  1359.               result)
  1360.           (setq result (:do-it))
  1361.           (with-open-printer (prec :view *print-record-window*)
  1362.             (get-print-prec *print-record-window*)
  1363.             (update-file-prec *print-record-window* (prec-get *print-record-window*)))
  1364.           result)
  1365.         :when :around)
  1366.  
  1367. (let ((*warn-if-redefine* nil)
  1368.       (*warn-if-redefine-kernel* nil))
  1369.   
  1370.   (defun get-print-record ()
  1371.     (if *print-record-window*
  1372.       (get-prec *print-record-window*)
  1373.       (funcall *mcl-get-print-record*)))
  1374.   
  1375.   )
  1376.  
  1377.  
  1378. #|
  1379. (defun make-print-demo ()
  1380.   "Create the experiment application"
  1381.   (let ((target-appl (choose-new-file-dialog :directory "ccl;print-demo")))
  1382.     (save-application target-appl
  1383.                       :excise-compiler nil    ; do want the compiler
  1384.                       :creator :glop
  1385.                       :clear-clos-caches nil ; otherwise we can't access classes
  1386.                       )))
  1387. (make-print-demo)
  1388. |#
  1389.  
  1390. #|
  1391. ;;;  Four printing examples and two examples of saving private print records
  1392. ;;;
  1393. ;;;  Four printing examples:
  1394. ;;;  - contents of a small window
  1395. ;;;  - a picture
  1396. ;;;  - contents of a large window
  1397. ;;;  - a general document
  1398.  
  1399. (defvar *w1*)
  1400. (defvar *test-window*)
  1401. (defvar *picture*)
  1402.  
  1403.  
  1404.  
  1405. ;;---------------------- printing the contents of a small window ------------------------
  1406. ;; Create a window with nested views and print it.
  1407. (setq *w1* (make-instance 'window
  1408.             :window-title "HI there"
  1409.             :view-size #@(300 300)
  1410.             :view-subviews
  1411.                (list (make-instance 'view
  1412.                    :view-position #@(20 20)
  1413.                    :view-size #@(150 130)
  1414.                    :view-subviews
  1415.                        (List (make-instance 'static-text-dialog-item
  1416.                                  :view-position #@(10 10)
  1417.                                  :view-size #@(130 40)
  1418.                                  :view-font '("Helvetica" :srcor :bold 12)
  1419.                                  :dialog-item-text
  1420.                                     "how now said the big brown cow")
  1421.                              (make-instance 'static-text-dialog-item
  1422.                                             :view-position #@(10 70)
  1423.                                             :view-size #@(130 60)
  1424.                                             :view-font '("Geneva" :srcor :underline 14)
  1425.                                             :dialog-item-text
  1426.                                             "there is a bunch of green cheese here on the moon")))
  1427.                      (make-instance 'button-dialog-item
  1428.                                             :view-position #@(160 160)
  1429.                                             :view-size #@(72 16)
  1430.                                             :dialog-item-text "Green"))))
  1431.  
  1432. (window-hardcopy *w1*)                  ; print the window
  1433.                                         ; Also select the window and do a file Print
  1434.  
  1435. ;;---------------------------- printing a picture -----------------------------
  1436. ;; Print a picture. The picture corresponds to a picture of the print-contents
  1437. ;; of the window w1
  1438. (let ((view-size (view-size *w1*)) mid-point)
  1439.   (when (and (boundp '*picture*) (handlep *picture*))
  1440.     (kill-picture *picture*))
  1441.   (with-focused-view *w1*
  1442.     (start-picture *w1* #@(0 0) (make-point (* 2 (point-h view-size))
  1443.                                             (* 2 (point-v view-size))))
  1444.     (print-contents *w1*)
  1445.     (setq *picture* (get-picture *w1*)))
  1446.  
  1447.   ;; draw the picture at half- in the bottom right corner of *w1*
  1448.   (window-select *w1*)
  1449.   (sleep 1)
  1450.   (setq mid-point (make-point (floor (point-h view-size) 2)
  1451.                               (floor (point-v view-size) 2)))
  1452.   (draw-picture *w1* *picture* mid-point (add-points (view-size *w1*) mid-point))
  1453.   (sleep 1)
  1454.   (picture-hardcopy *picture*)              ; print the picture
  1455.   (kill-picture *picture*)                  ; remove the picture
  1456.   )
  1457.  
  1458.  
  1459. ;;;  - 
  1460. ;;-------------------- printing the contents of a large window ---------------------
  1461. ;;  Print the contents of a large dialog (918 x 708) 
  1462. (setq *test-window*
  1463.    (make-instance 'color-dialog
  1464.                :window-type :document-with-zoom 
  1465.                :view-position #@(100 100)
  1466.                :view-size #@(918 708)
  1467.                :view-font '("Chicago" 12 :SRCOR :PLAIN)
  1468.                :view-subviews
  1469.                (list (make-instance 'static-text-dialog-item
  1470.                                        :view-position #@(13 9)
  1471.                                        :view-size #@(56 16)
  1472.                                        :dialog-item-text "Untitled")
  1473.  
  1474.                      (make-instance 'editable-text-dialog-item
  1475.                                        :view-position #@(15 25)
  1476.                                        :view-size #@(84 16)
  1477.                                        :dialog-item-text "Untitled"
  1478.                                        :allow-returns nil)
  1479.  
  1480.                      (make-instance 'button-dialog-item
  1481.                                        :view-position #@(15 47)
  1482.                                        :view-size #@(62 16)
  1483.                                        :dialog-item-text "Untitled"
  1484.                                        :default-button nil)
  1485.  
  1486.                      (make-instance 'editable-text-dialog-item
  1487.                                        :view-position #@(381 683)
  1488.                                        :view-size #@(114 16)
  1489.                                        :dialog-item-text "bottom center"
  1490.                                        :allow-returns nil)
  1491.  
  1492.                      (make-instance 'editable-text-dialog-item
  1493.                                        :view-position #@(11 688)
  1494.                                        :view-size #@(84 16)
  1495.                                        :dialog-item-text "bottom left"
  1496.                                        :allow-returns nil)
  1497.  
  1498.                      (make-instance 'editable-text-dialog-item
  1499.                                        :view-position #@(375 20)
  1500.                                        :view-size #@(84 16)
  1501.                                        :dialog-item-text "top center"
  1502.                                        :allow-returns nil)
  1503.  
  1504.                      (make-instance 'editable-text-dialog-item
  1505.                                        :view-position #@(799 676)
  1506.                                        :view-size #@(84 16)
  1507.                                        :dialog-item-text "bottom right"
  1508.                                        :view-font
  1509.                                        '("New Century Schlbk"
  1510.                                          12 :SRCOR :PLAIN)
  1511.                                        :allow-returns nil)
  1512.  
  1513.                      (make-instance 'editable-text-dialog-item
  1514.                                        :view-position #@(818 20)
  1515.                                        :view-size #@(84 16)
  1516.                                        :dialog-item-text "top right"
  1517.                                        :view-font
  1518.                                        '("New Century Schlbk"
  1519.                                          12 :SRCOR :PLAIN)
  1520.                                        :allow-returns nil)))
  1521. )
  1522.  
  1523. (window-hardcopy *test-window*)           ; print the large dialog
  1524.  
  1525. ;;---------------------- printing a general document -----------------------
  1526. ;;  Print a document of size 552 x 1460 pixels
  1527. ;;  This requires two 8.5" x 11" pages at normal size (Reduce/Enlarge 100%)
  1528. ;;  At normal size prints two pages with 
  1529. ;;  "Now is the time for all good men to come to the aid" on the first page
  1530. ;;  twice on the first page at #@(50 50) and #@(50 100)
  1531. ;;  and with the string "When johnny comes marching home again" in the
  1532. ;;  relative positions #@(200 0) and #@(50 100) on the second page.
  1533. ;;  At 50% or smaller reduction, prints only the first page, reduced.
  1534. ;;  At 200% or greater reduction prints two pages, enlarged.
  1535.  
  1536. ;;  When 50% reduction, prints only one "page"
  1537. (defun my-hardcopy-fn (view page-size page-no offset local)
  1538.   (declare (ignore view page-size))
  1539.   (unless local (setq offset #@(0 0)))
  1540.   (let ((text "Now is the time for all good men to come to the aid"))
  1541.     (with-font-spec '("Times" 18 :srcor :plain)
  1542.       (if (= page-no 0)
  1543.         (#_moveTo :long (add-points #@(50 50) offset))
  1544.         (progn (#_moveTo :long (add-points #@(200 0) offset))
  1545.                (setq text "When johnny comes marching home again")))
  1546.       (with-returned-pstrs ((text-buff text))
  1547.         (#_DrawText :ptr text-buff :integer 1 :integer (length text)))
  1548.       (#_moveTo :long (add-points #@(50 100) offset))
  1549.       (with-returned-pstrs ((text-buff text))
  1550.         (#_DrawText :ptr text-buff :integer 1 :integer (length text)))
  1551.       )))
  1552.  
  1553. (defun my-document-corners (view page-size)
  1554.   (declare (ignore view page-size))
  1555.   ;; a document on 8.5 x 11 paper 1 wide and 2 high
  1556.   (values #@(0 0) (make-point 552 (* 2 730))))
  1557.  
  1558. (document-hardcopy #'my-hardcopy-fn #'my-document-corners)   ; print the document
  1559.  
  1560. ;;;  - 
  1561. ;;-------------------- changing the page setup atributes of a file ---------------------
  1562. ;; open an existing file in a fred window,
  1563. ;; change the page setup attributes and reopen the file 
  1564. (defvar *test-window*)
  1565. (defvar *file-name*)
  1566. (setq *test-window* (fred (choose-file-dialog :button-string "Edit")))
  1567. (setq *file-name* (view-file-name *test-window*))
  1568.  
  1569. ;; Change the page setup   
  1570. (page-setup *test-window*)
  1571. (window-close *test-window*)
  1572.  
  1573. ;; open the file again and see that the attributes have changed
  1574. (setq *test-window* (edit-select-file))
  1575. (page-setup *test-window*)
  1576.  
  1577. ;; open the file and see that the :prec resource has been saved
  1578. (with-open-resource-file (refnum *file-name* :if-does-not-exist nil)
  1579.   (let (printer-record)
  1580.     (setq printer-record (get-resource :prec 128 :errorp nil))
  1581.     (print-db printer-record)
  1582.     (when (valid-handle printer-record)
  1583.       (print-record printer-record :tprint))))
  1584.  
  1585. ;;;  - 
  1586. ;;-------------------- views that store their print record in a slot ---------------------
  1587. ;;  the slot is ccl::my-print-record
  1588.  
  1589. (defclass print-view (view)
  1590.   ((my-print-record :initform nil)
  1591.    (my-file-name :initform nil)))
  1592.  
  1593. (defclass print-window (print-view window) nil)
  1594.  
  1595. (defmethod view-file-name ((view print-view))
  1596.   (slot-value view 'my-file-name))
  1597.  
  1598. (defmethod view-get ((view print-view) flag &optional option)
  1599.   (declare (ignore option))
  1600.   (if (equal flag :prec)
  1601.       (slot-value view 'my-print-record)
  1602.       (call-next-method)))
  1603.  
  1604. (defmethod view-put ((view print-view) flag value)
  1605.   (if (equal flag :prec)
  1606.     (setf (slot-value view 'my-print-record) value)
  1607.     (call-next-method)))
  1608.  
  1609. (setq *test-window* (make-instance 'print-window))
  1610. (setq *file-name* (choose-new-file-dialog))
  1611.  
  1612. ;; change the page setup attributes, they'll be saved with the file
  1613. (page-setup *test-window*)
  1614. (window-close *test-window*)
  1615.  
  1616. ;; create another window into the same "file"
  1617. ;; and see that the print-record has been restored.
  1618. (setq *test-window* (make-instance 'print-window))
  1619. (setf (slot-value *test-window* 'my-file-name) *file-name*)
  1620. (page-setup *test-window*)
  1621. |#
  1622.  
  1623. ;;; end of file
  1624.